home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / MODULES / RULES / Rule-Forward.lisp < prev    next >
Encoding:
Text File  |  1990-06-24  |  23.7 KB  |  490 lines  |  [TEXT/CCL ]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         Rule-Forward.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      19-Oct-88 21:57:32
  17. ; Modified:     22-Jun-90 02:18:10 (Dan Suthers)
  18. ; Language:     Common Lisp
  19. ; Package:      RULE
  20. ;
  21. ; Description:  Rule-based reasoner built on the pattern matching facilities
  22. ;               of DNET.  Supports forward and backward reasoning.
  23. ;
  24. ;               This file contains only the code for forward reasoning.
  25. ;               See also Rule-Defs, Rule-Build, and Rule-Back.
  26. ;               File RULES has documentation.
  27. ;
  28. ; (c) Copyright 1988, by Daniel D. Suthers
  29. ;                        Department of Computer and Information Science
  30. ;                        University of Massachusetts
  31. ;                        Amherst, Massachusetts 01003
  32. ;
  33. ; This software was conceived, designed, and written by Dan Suthers 
  34. ; while supported by the National Science Foundation under grant number
  35. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  36. ; CA.  Partial support was also received from the Office of Naval Research
  37. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  38. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  39. ; the above grants and encouraged me to pursue my own research interests in
  40. ; her lab.  This work would not have been possible without the resources and
  41. ; stimulating environment of the Computer and Information Science department.
  42. ;
  43. ; Permission to use, modify, and distribute this software is granted subject 
  44. ; to the following restrictions and understandings:
  45. ; 1. The file header, including this notice, shall be retained, and may be
  46. ;    extended to include documentation of modifications to the software.
  47. ; 2. This material is for nonprofit educational and research purposes only.
  48. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  49. ;    noteworthy uses of this software.
  50. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  51. ;    representation that the operation of this software will be error free,
  52. ;    and are under no obligation to provide any services.
  53. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  54. ;    Suthers and the University of Massachusetts from all claims arising 
  55. ;    out of the use or misuse of this software, or arising out of any 
  56. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  57. ;    fees, and liabilities incurred in or about any such claim, action, or
  58. ;    proceeding brought thereon.
  59. ; 5. All materials and reports developed as a consequence of the use of 
  60. ;    this software shall duly acknowledge such use, in accordance with
  61. ;    the usual standards of acknowledging credit in academic research.
  62. ;
  63. ; Status:       Working, subject to change.
  64. ;
  65. ; Changes:
  66. ;   30-Dec-88 :DELETE added to forward rules.
  67. ;   25-Mar-89 Cleanup; removed bogus comments prohibiting nested :AND.
  68. ;
  69. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70.  
  71. (in-package :RULE)
  72.  
  73. (export '(
  74.  
  75.           forget-previous-bindings
  76.           forward-chain
  77.           infer-from-datum
  78.           translate
  79.           
  80.           ))
  81.  
  82. (require :Rule-Defs)
  83. (use-package :DNET)
  84.  
  85. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  86. ;;;
  87. ;;;                      INTERNAL FUNCTIONS AND MACROS
  88. ;;;
  89. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90. ;;; Little Helpers
  91.  
  92. (eval-when (compile eval)
  93.  
  94.   ;; A version of this without bindings appears in RULE-BACK. 
  95.   (defmacro LISP-ESCAPE (bindings forms)
  96.     `(progv (mapcar #'car ,bindings) (mapcar #'cdr ,bindings)
  97.        ;; Want to return the last form evaluated, which dolist won't do.
  98.        (do ((fptr ,forms (cdr fptr)))
  99.             ((null (cdr fptr)) (eval (car fptr)))
  100.           (declare (list fptr))
  101.           (eval (car fptr)))))
  102.  
  103.   (defmacro TRACE-FORWARD-RULE (label datum rule-record bindings)
  104.     ;; Print a trace of a forwards application of a rule, if turned on.
  105.     `(if *rule-trace*
  106.        #-:CCL (format *rule-trace* "~&~A: ~S -- ~S --> ~S"
  107.                       ,label ,datum (rule-record-rule-name ,rule-record)
  108.                       (substitute-bindings ,bindings 
  109.                                            (rule-record-pattern ,rule-record)))
  110.        #+:CCL (rule-trace "~&~A: ~S -- ~S --> ~S"
  111.                            ,label ,datum (rule-record-rule-name ,rule-record)
  112.                            (substitute-bindings ,bindings 
  113.                                                 (rule-record-pattern ,rule-record)))
  114.        ))
  115.  
  116.   ) ; eval-when
  117.  
  118. (defun SUBSTITUTE-BINDINGS-AND-LISP (bindings pattern &aux binding)
  119.   ;; Like substitute-bindings in DNET, but also replaces :lisp with value.
  120.   (declare (list bindings binding) 
  121.            (optimize (safety 1) (space 2) (speed 3)))
  122.   (cond ((null pattern) nil)
  123.         ((atom pattern)
  124.          (if (and (variable-p pattern)
  125.                   (setf binding (assoc pattern bindings)))
  126.            (cdr binding)
  127.            pattern))
  128.         ((eq (first pattern) :lisp)
  129.          (lisp-escape bindings (rest pattern)))
  130.         (T
  131.          (cons (substitute-bindings-and-lisp bindings (car pattern))
  132.                (substitute-bindings-and-lisp bindings (cdr pattern))))))
  133. (proclaim '(function substitute-bindings-and-lisp (list t) t))
  134.  
  135. ;;;-----------------------------------------------------
  136. ;;; Applying the consequent.  Returns T iff datum added.
  137.  
  138. (defun DO-CONSEQUENT (pattern bindings data-dnet rule-name grounds)
  139.   (declare (list pattern bindings) (symbol data-dnet rule-name))
  140.   (case (car pattern)
  141.     ((:LISP) 
  142.      (lisp-escape bindings (cdr pattern)) 
  143.      nil)
  144.     ((:DELETE) 
  145.      (delete-datum-internal 
  146.       (substitute-bindings-and-lisp bindings (second pattern)) data-dnet)
  147.      nil)
  148.     (otherwise
  149.      (add-datum-internal 
  150.       (substitute-bindings-and-lisp bindings pattern) 
  151.       data-dnet rule-name grounds))))
  152. (proclaim '(function do-consequent (list list symbol symbol t) t))
  153.  
  154. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  155. ;;; Forward Chaining
  156.  
  157. ;;;-----------------------------
  158. ;;; One shot forward application
  159.  
  160. (defun INFER-FROM-DATUM-INTERNAL (datum data-dnet rule-dnet)
  161.   (declare (symbol data-dnet rule-dnet)
  162.            (optimize (safety 1) (space 2) (speed 3)))
  163.  
  164.   ;; Plunk the datum into an antecedent template and find matching rules to run.
  165.   (setf (cdr *antecedent-template*) datum)
  166.   (multiple-value-bind
  167.     (antecedents bindings)
  168.     (dnet::match-expression-internal *antecedent-template* rule-dnet nil)
  169.     (declare (list antecedents bindings))
  170.     (do ((aptr antecedents (cdr aptr))
  171.          (bptr bindings    (cdr bptr)))
  172.         ((null aptr))
  173.       (declare (list aptr bptr))
  174.  
  175.       ;; Process each factored pattern in the rule's consequent.
  176.       ;; Unrepeatable rules processed separately to test and save bindings.
  177.       ;; (The code is repeated to avoid penalizing repeatables with tests.)
  178.       (dolist (rule-record (dnet::expr-info-internal (first aptr) rule-dnet))
  179.         (declare (list rule-record))
  180.         (if (rule-record-repeatable rule-record)
  181.           (let ((pattern (rule-record-pattern rule-record)))
  182.             (declare (list pattern))
  183.             (trace-forward-rule "F" datum rule-record (first bptr))
  184.             (do-consequent pattern (first bptr) 
  185.                            data-dnet (rule-record-rule-name rule-record) datum))
  186.           (if (not (member (first bptr) 
  187.                            (rule-record-bindings rule-record) :test #'equal))
  188.             (let ((pattern (rule-record-pattern rule-record)))
  189.               (declare (list pattern))
  190.               (trace-forward-rule "F!" datum rule-record (first bptr))
  191.               (do-consequent pattern (first bptr) 
  192.                              data-dnet (rule-record-rule-name rule-record) datum)
  193.               (push (first bptr) (rule-record-bindings rule-record)))))))))
  194.  
  195. ;;;--------------------------------
  196. ;;; Forward Chaining on a Data Base DNET
  197.  
  198. ;;; Separated for legibility, this does one pass of the forward chainer.  
  199. ;;; Sets datum-added only if the indexer says a datum wasn't there before.
  200.  
  201. (eval-when (eval compile)
  202.  
  203.   (defmacro FORWARD-CHAIN-PASS (end-list+rule-terminals data-dnet datum-added)
  204.     `(dolist (end+terminal ,end-list+rule-terminals)
  205.        (declare (cons end+terminal)
  206.                 (optimize (safety 1) (space 2) (speed 3)))
  207.        
  208.        ;; Get all the data that the rule succeeds on, and their bindings.
  209.        (multiple-value-bind
  210.          (grounds bindings)
  211.          (get-matches ,data-dnet (cdr (dnet-terminal-expr (cdr end+terminal))) nil)
  212.          (declare (list grounds bindings))
  213.          
  214.          ;; Iterate over the matching data and associated bindings ...
  215.          (do ((gptr grounds  (rest gptr))
  216.               (bptr bindings (rest bptr)))
  217.              ((null gptr))
  218.            (declare (list gptr bptr))
  219.            
  220.            ;; There may be multiple consequents per antecedent.  Execute each of
  221.            ;; these consequents for the current matching datum and bindings. 
  222.            ;; Separate code for repeatable and unrepeatable so we don't penalize
  223.            ;; speed of former for latter's tests.
  224.            (dolist (rule-record (dnet-terminal-info (cdr end+terminal)))
  225.              (declare (list rule-record))
  226.              (if (rule-record-repeatable rule-record)
  227.                (let ((pattern (rule-record-pattern rule-record)))
  228.                  (declare (list pattern))
  229.                  (trace-forward-rule "F" (first gptr) rule-record (first bptr))
  230.                  (if (do-consequent pattern (first bptr) data-dnet
  231.                                     (rule-record-rule-name rule-record) (first gptr))
  232.                    (setf ,datum-added t)))
  233.                (if (not (member (first bptr) 
  234.                                 (rule-record-bindings rule-record) :test #'equal))
  235.                  (let ((pattern (rule-record-pattern rule-record)))
  236.                    (declare (list pattern))
  237.                  (trace-forward-rule "F!" (first gptr) rule-record (first bptr))
  238.                    (if (do-consequent pattern (first bptr) data-dnet 
  239.                                       (rule-record-rule-name rule-record) (first gptr))
  240.                      (setf ,datum-added t))
  241.                    (push (first bptr) (rule-record-bindings rule-record))))))))))
  242.  
  243.   ) ; eval-when
  244.  
  245. (defvariable ?::expr)
  246.  
  247. (defun FORWARD-CHAIN-INTERNAL (data-dnet rule-dnet chain-bound)
  248.   ;; Apply the batch forward chainer (which interprets :AND, etc) as long
  249.   ;; as data are added, but not any more times than <chain-bound>.
  250.   (declare (symbol data-dnet rule-dnet) (fixnum chain-bound)
  251.            (optimize (safety 1) (space 2) (speed 3)))
  252.   (do ((cycle 0 (1+ cycle))
  253.        (datum-added t) ; get past entry
  254.        (end-list+rule-terminals
  255.         (dnet::pattern-match-links '(:antecedent . ?:expr)
  256.                              (list (dnet::dnet-link (sm:gets 'dnet rule-dnet))))))
  257.       ((or (null datum-added) (> cycle chain-bound)) cycle)
  258.     (declare (fixnum cycle) (list rule-terminals))
  259.     (setf datum-added nil)
  260.     (forward-chain-pass end-list+rule-terminals data-dnet datum-added)))
  261.  
  262. ;;;------------------------------------------------------------------------
  263. ;;; GET-MATCHES is responsible for interpreting the special operators :LISP 
  264. ;;; and :BIND, as well as for the base case of matching to the data base DNET.
  265. ;;; It uses MATCH-CONJUNCTS to deal with the interpretation of :AND and :SEQ, and
  266. ;;; splitting due to multiple matching data. Each call to GET-MATCHES gets
  267. ;;; an antecedent and a set of bindings as arguments, and returns an ordered
  268. ;;; list of grounds and a corresponding list of bindings, similar to the DNET
  269. ;;; match functions.  A "ground" is whatever justified the success of the rule.
  270.  
  271. (defun GET-MATCHES (data-dnet antecedent bindings)
  272.   (declare (symbol data-dnet) (list antecedent bindings)
  273.            (optimize (safety 1) (space 2) (speed 3)))
  274.   (case (first antecedent)
  275.  
  276.     ;; :AND and :SEQ must succeed on all subcalls with consistent bindings.
  277.     ((:and :seq) (match-conjuncts data-dnet (rest antecedent) nil bindings))
  278.  
  279.     ;; :LISP succeeds if evaluation does; no effect on bindings.  The ground
  280.     ;; is the value returned by lisp, so we can later figure out what happened.
  281.     ((:lisp) (let ((lisp-result (lisp-escape bindings (cdr antecedent))))
  282.                (if lisp-result
  283.                  (values (list lisp-result) (list bindings))
  284.                  (values nil nil))))
  285.  
  286.     ;; :BIND adds to current bindings if it is consistent, else fails.  It 
  287.     ;; succeeds even if the lisp result is nil.  (OK to return (nil) grounds.)
  288.     ((:bind) (let ((lisp-result (lisp-escape bindings (cddr antecedent)))
  289.                    (prev-binding (assoc (second antecedent) bindings)))
  290.                (if prev-binding
  291.                  (if (equal (cdr prev-binding) lisp-result)
  292.                    (values (list lisp-result) (list bindings))
  293.                    (values nil nil))
  294.                  (values (list lisp-result)
  295.                          (list (push (cons (second antecedent) lisp-result) 
  296.                                      bindings))))))
  297.  
  298.     ;; Anything else must match directly. 
  299.     (otherwise (dnet::match-pattern-internal antecedent data-dnet bindings))))
  300.  
  301. ;;;------------------------------------------------------------------------
  302. ;;; MATCH-CONJUNCTS deals with two complications of forward chaining conjuncts:
  303. ;;; - :AND requires iterating over a sequence of antecedents to find a sequence
  304. ;;;   of matching data with consistent bindings.
  305. ;;; - Matching one of these antecedents against a data dnet may produce more 
  306. ;;;   than one datum that matches.  Whenever this happens, :AND processing must
  307. ;;;   split, processing the remaining conjuncts in the context of each match.
  308.  
  309. ;;; MATCH-CONJUNCTS is given some antecedents to consume, a grounds list of
  310. ;;; form (<ground1> ... <groundK>), and a single binding-set.  Each element
  311. ;;; of the grounds list matches a corresponding antecedent which has already
  312. ;;; been consumed, with the indicated binding-set.  In consuming the remaining
  313. ;;; antecedents, we may find several ways to do it.  Hence we have to return
  314. ;;; a list of extensions and their binding sets, of form:
  315. ;;; ((<ground1> ... <groundK> <groundL>) ... (<ground1> ... <groundK> <groundM>))
  316. ;;; (      <binding-setL>                          <binding-setM>               )
  317. ;;; [There may be more grounds added after <groundL> and <groundM>; this just 
  318. ;;; gives the gist of it.]  After the function splits on the first of the 
  319. ;;; remaining antecedents, it calls itself on each element of this list, thus 
  320. ;;; dividing the work, and unions the results.
  321.  
  322. (defun MATCH-CONJUNCTS (data-dnet remaining-antecedents grounds bindings)
  323.   (declare (symbol data-dnet) (list remaining-antecedents grounds bindings)
  324.            (optimize (safety 1) (space 2) (speed 3)))
  325.   (if (null remaining-antecedents)
  326.  
  327.     ;; No more remaining antecedents: the unextended grounds is returned.
  328.     ;; (The extra recursive call before this base case is to cover (:AND).)
  329.     (values (list grounds) (list bindings))
  330.  
  331.     ;; Get the grounds which match the next remaining antecedent.  (The
  332.     ;; get-matches call will use bindings to check consistency.)
  333.     (multiple-value-bind
  334.       (extensions extended-bindings)
  335.       (get-matches data-dnet (first remaining-antecedents) bindings)
  336.       (declare (list extensions extended-bindings))
  337.  
  338.       ;; Extend the ground with each match (the mapcar), and recurse separately 
  339.       ;; on each extended grounds to consume the rest of the remaining antecedents.
  340.       (do ((gptr (mapcar #'(lambda (e) (append grounds (list e))) extensions)
  341.                  (rest gptr))
  342.            (bptr extended-bindings (rest bptr))
  343.            (result-grounds  (list :head))
  344.            (result-bindings (list :head)))
  345.           ((null gptr) (values (rest result-grounds) (rest result-bindings)))
  346.         (declare (list gptr bptr result-grounds result-bindings))
  347.         (multiple-value-bind
  348.           (new-grounds-list new-bindings-list)
  349.           (match-conjuncts 
  350.            data-dnet (rest remaining-antecedents) (first gptr) (first bptr))
  351.           (declare (list new-grounds-list new-bindings-list))
  352.           (nconc result-grounds  new-grounds-list)
  353.           (nconc result-bindings new-bindings-list))))))
  354.  
  355. ;;;------------------------------------------------------------
  356. ;;; Forward application which translates one DNET into another.
  357.  
  358. (defun TRANSLATE-INTERNAL (source-dnet target-dnet rule-dnet)
  359.   (declare (symbol source-dnet target-dnet rule-dnet)
  360.            (optimize (safety 1) (space 2) (speed 3)))
  361.  
  362.   ;; Iterate over (:end-list . <dnet-terminal>)'s for each forward rule. 
  363.   (dolist (end+terminal (dnet::pattern-match-links 
  364.                          '(:antecedent . ?:expr)
  365.                          (list (dnet::dnet-link (sm:gets 'dnet rule-dnet)))))
  366.     (declare (cons end+terminal))
  367.        
  368.     ;; Get all the data that the rule succeeds on, and their bindings.
  369.     (multiple-value-bind
  370.       (grounds bindings)
  371.       (get-matches source-dnet (cdr (dnet-terminal-expr (cdr end+terminal))) nil)
  372.       (declare (list grounds bindings))
  373.          
  374.       ;; Iterate over the matching data and associated bindings ...
  375.       (do ((gptr grounds  (rest gptr))
  376.            (bptr bindings (rest bptr)))
  377.           ((null gptr))
  378.         (declare (list gptr bptr))
  379.            
  380.         ;; There may be multiple consequents per antecedent.  Execute each of
  381.         ;; these consequents for the current matching datum and bindings. 
  382.         ;; (Repeatable option not processed in TRANSLATE.)
  383.         (dolist (rule-record (dnet-terminal-info (cdr end+terminal)))
  384.           (declare (list rule-record))
  385.           (let ((pattern (rule-record-pattern rule-record)))
  386.             (declare (list pattern))
  387.             (trace-forward-rule "T" (first gptr) rule-record (first bptr))
  388.             (do-consequent pattern (first bptr) target-dnet
  389.                            (rule-record-rule-name rule-record) (first gptr))))))))
  390.  
  391. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  392. ;;;
  393. ;;;                        USER INTERFACE FUNCTIONS
  394. ;;;
  395. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  396.  
  397. (defun INFER-FROM-DATUM (datum data-dnet rule-dnet)
  398.   "infer-from-datum <datum> <data-dnet> <rule-dnet>                   [Function]
  399.   Triggers whatever rules in <rule-dnet> immediately match <datum>, adding
  400.   newly derived data to <data-dnet>.  The warrant of the justification
  401.   of each derived datum is the rule used to derive it, and the ground is 
  402.   the expression which matched the antecedent. 
  403.     This does NOT chain, nor does it interpret :AND, :SEQ, :LISP, or :BIND
  404.   in the antecedent. :OR in the antecedent was handled when the rule was 
  405.   factored by ADD-RULE.  It does interpret :LISP in the consequent, and
  406.   :AND there was taken care of by ADD-RULE. This function is intended to
  407.   be used in the INDEXPR-HOOK of data DNETs which do simple 'reflexive' 
  408.   reasoning on the addition of a datum, and don't need these extra frills.
  409.   Chaining WILL result if the INDEXPR-HOOK of <rule-dnet> calls this 
  410.   INFER-FROM-DATUM on newly added data."
  411.   ;; Why don't I just return a list of data, and let the user indexpr 
  412.   ;; them if desired?  Because then the warrant & grounds would be lost.
  413.  
  414.   (declare (inline infer-from-datum-internal))
  415.   (check-type data-dnet symbol)
  416.   (check-type rule-dnet symbol)
  417.   (assert (sm:gets 'dnet data-dnet) (data-dnet) 
  418.           "[DNET:INFER-FROM-DATUM] ~S is not a known DNET." data-dnet)
  419.   (assert (sm:gets 'dnet rule-dnet) (rule-dnet)
  420.           "[DNET:INFER-FROM-DATUM] ~S is not a known DNET." rule-dnet)
  421.   (if *rule-trace* (format *rule-trace* "~&---------- Call to INFER-FROM-DATUM:"))
  422.   (infer-from-datum-internal datum data-dnet rule-dnet))
  423.  
  424. (defun FORWARD-CHAIN (data-dnet rule-dnet
  425.                             &optional (chain-limit most-positive-fixnum))
  426.   "forward-chain <data-dnet> <rule-dnet> &optional chain-limit      [Function]
  427.   Derives all conclusions from <data-dnet> allowed by the forward rules
  428.   in <rule-dnet>, and adds them to <data-dnet>.  If new data are added,
  429.   the process repeats.  <Chain-limit> indicates how many times this may 
  430.   repeat: it defaults to MOST-POSITIVE-FIXNUM.  The warrant of the 
  431.   justification of each derived datum is the rule used to derive it, and
  432.   the ground is the expression which matched the antecedent, or the 
  433.   result of evaluation in the case of :LISP or :BIND.  :AND and :SEQ are
  434.   handled.
  435.     NOTE that no attempt is made to synchronize rule firing.  On each
  436.   pass through the forward rules, later rules will see data added by
  437.   earlier rules.  Thus it is possible that rule chaining will occur in
  438.   one 'pass', if they happen to be seen in the fortuitious order.  You
  439.   can aid this by entering rules into the DNET in the order in which 
  440.   they chain, eg. if rule-1 triggers rule-2 triggers rule3, add-rule
  441.   them in this order.  This saves re-testing rules that won't fire."
  442.   (declare (inline forward-chain-internal))
  443.   (check-type data-dnet symbol)
  444.   (check-type rule-dnet symbol)
  445.   (check-type chain-limit fixnum)
  446.   (assert (sm:gets 'dnet data-dnet) (data-dnet) 
  447.           "[DNET:FORWARD-CHAIN] ~S is not a known DNET." data-dnet)
  448.   (assert (sm:gets 'dnet rule-dnet) (rule-dnet) 
  449.           "[DNET:FORWARD-CHAIN] ~S is not a known DNET." rule-dnet)
  450.   (if *rule-trace* (format *rule-trace* "~&---------- Call to FORWARD-CHAIN:"))
  451.   (forward-chain-internal data-dnet rule-dnet chain-limit))
  452.  
  453. (defun FORGET-PREVIOUS-BINDINGS (rule-dnet)
  454.   "forget-previous-bindings <rule-dnet>                             [Function]
  455.   Erases all memory of previous forward rule bindings, so :forward-unique 
  456.   filtering starts anew."
  457.   (check-type rule-dnet symbol)
  458.   (assert (sm:gets 'dnet rule-dnet) (rule-dnet) 
  459.           "[DNET:FORGET-PREVIOUS-BINDINGS] ~S is not a known DNET." rule-dnet)
  460.   (map-dnet-terminals
  461.    #'(lambda (dt) 
  462.        (map nil #'(lambda (rule-record)
  463.                     (declare (list rule-record))
  464.                     (unless (rule-record-repeatable rule-record)
  465.                       (setf (rule-record-bindings rule-record) nil)))
  466.             (dnet-terminal-info dt)))
  467.    rule-dnet))
  468.  
  469. (defun TRANSLATE (source-dnet target-dnet rule-dnet)
  470.   "translate <source-dnet> <target-dnet> <rule-dnet>                [Function]
  471.   Derives all conclusions from <source-dnet> allowed by the forward rules
  472.   in <rule-dnet>, and adds them to <target-dnet>.  Useful for rules that
  473.   translate between representations."
  474.   (declare (inline translate-internal))
  475.   (check-type source-dnet symbol)
  476.   (check-type target-dnet symbol)
  477.   (check-type rule-dnet symbol)
  478.   (assert (sm:gets 'dnet source-dnet) (source-dnet) 
  479.           "[DNET:TRANSLATE] ~S is not a known DNET." source-dnet)
  480.   (assert (sm:gets 'dnet target-dnet) (target-dnet) 
  481.           "[DNET:TRANSLATE] ~S is not a known DNET." target-dnet)
  482.   (assert (sm:gets 'dnet rule-dnet) (rule-dnet) 
  483.           "[DNET:TRANSLATE] ~S is not a known DNET." rule-dnet)
  484.   (if *rule-trace* (format *rule-trace* "~&---------- Call to TRANSLATE:"))
  485.   (translate-internal source-dnet target-dnet rule-dnet))
  486.  
  487. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  488. (provide :rule-forward)
  489. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  490. ;;; the end.